(in-package :iorek)

(defun char-line-terminator-p (ch)
  (or (char= ch #\Newline)
      (char= ch #\Return)))

(defun char-whitespace-p (ch)
  (or (char= ch #\Space)
      (char= ch #\Tab)))

(defun symbol-terminator-p (ch)
  (or (char-whitespace-p ch)
      (char-line-terminator-p ch)
      (char= #\( ch)
      (char= #\) ch)
      (char= #\[ ch)
      (char= #\] ch)))

(defun %read-number (ch stream)
  (let* ((string (with-output-to-string (s)
                   (princ ch s)
                   (loop
                      (setf ch (read-char stream nil :eof))
                      (cond
                        ((eq ch :eof)
                         (return))
                        ((or (digit-char-p ch)
                             (char= ch #\+)
                             (char= ch #\-)
                             (char= ch #\.)
                             (char= ch #\/)
                             (char= ch #\E))
                         (princ ch s))
                        (t (unread-char ch stream)
                           (return))))))
         (cl:*read-eval* nil)
         (object (cl:read-from-string string)))
    (if (numberp object)
        (if (equal ch #\i)
            (progn
              (read-char stream) ;;Consume #\i
              (* object #C(0 1))) ;;Complex number, return [0 + <number>i]
            object)
        (error "Not a number: ~A" object))))

(defun %read-symbol (ch stream namespace intern)
  (let* ((continue nil)
         (eof-value :eof)
         (symbol-name
          (with-output-to-string (s)
            (when ch (cl:princ ch s))
            (loop
               (setf ch (read-char stream nil eof-value))
               (cond
                 ((eq ch eof-value)
                  (return))
                 ((char= ch #\:)
                  (setf continue t)
                  (return))
                 ((symbol-terminator-p ch)
                  (unread-char ch stream)
                  (return))
                 (t (cl:princ ch s)))))))
    (if (and (zerop (length symbol-name)) namespace)
	namespace ;;Allow trailing colon (as in "foo:")
	(let ((symbol (if intern
			  (intern symbol-name namespace)
			  (or (find-symbol symbol-name namespace nil)
			      (error "Unknown symbol: ~A in namespace ~A" symbol-name namespace)))))
	  (if continue
	    (%read-symbol nil stream symbol nil) ;Do not intern deeper than 1 level
	    symbol)))))

(define-condition list-terminated (error) ()
  (:report "Unmatched \")\""))

(defun %read-list (stream)
  (let ((seq (empty-seq)))
    (loop
       (handler-case
           (setf seq (with-last seq (read-object stream)))
         (list-terminated () (return))))
    seq))

(define-condition vector-terminated (error) ()
  (:report "Unmatched \"]\""))

(defun %read-vector (stream)
  (let ((v (make-array 0 :adjustable t :fill-pointer 0)))
    (loop
       (handler-case
           (vector-push-extend (read-object stream) v)
         (vector-terminated () (return))))
    v))

(define-condition map-terminated (error) ()
  (:report "Unmatched \"}""))

(defun %read-map (stream)
  (let ((m (fset:map)))
    (loop
       (let ((key
              (handler-case
                  (read-object stream)
                (map-terminated () (return)))))
         (setf (@ m key) (read-object stream))))
    m))

(defun %read-string (stream)
  ;;TODO interpolation
  (with-output-to-string (str)
    (let (escape)
      (loop
         (let ((ch (read-char stream)))
           (cond
             ((char= ch #\\)
              (setf escape (not escape))
              (unless escape
                (princ ch str)))
             ((char= ch #\")
              (if escape
                  (progn
                    (princ ch str)
                    (setf escape (not escape)))
                  (return)))
             (t (princ ch str))))))))

(defun read-object (stream)
  (let ((ch (read-char stream)))
    (cond
      ;;Number
      ((or (digit-char-p ch)
           (and
            (or (char= ch #\+)
                (char= ch #\-)
                (char= ch #\.))
            (digit-char-p (peek-char nil stream)))) ;;TODO handle end-of-file
       (%read-number ch stream))
      ;;Quote
      ((char= ch #\')
       (seq *symbol-lang-quote* (read-object stream)))
      ;;Templating
      ((char= ch #\`)
       (seq *symbol-lang-template* (read-object stream)))
      ((char= ch #\,)
       (if (char= (peek-char nil stream) #\@) ;;TODO handle end-of-file
           (progn
             (read-char stream)
             (seq *symbol-lang-insert-many* (read-object stream)))
           (seq *symbol-lang-insert* (read-object stream))))
      ;;Root symbol
      ((char= ch #\:)
       (%read-symbol nil stream *root-symbol* t))
      ;;List
      ((char= ch #\()
       (%read-list stream))
      ((char= ch #\))
       (error 'list-terminated))
      ;;Vector
      ((char= ch #\[)
       (%read-vector stream))
      ((char= ch #\])
       (error 'vector-terminated))
      ;;Map
      ((char= ch #\{)
       (%read-map stream))
      ((char= ch #\})
       (error 'map-terminated))
      ;;String
      ((char= ch #\")
       (%read-string stream))
      ;;Comment
      ((char= ch #\;)
       (read-line stream)
       (read-object stream))
      ;;Whitespace (skip)
      ((or (char-whitespace-p ch) (char-line-terminator-p ch))
       (read-object stream))
      ;;Symbol
      (t (%read-symbol ch stream *namespace* t)))))

(defun read-expression (stream)
  (let ((tokens (read-tokens stream)) (pieces (seq)))
    (when (null tokens) ;;TODO is nil the right thing to return here?
      (return-from read-expression))
    (loop
       (let ((ch (peek-char nil stream nil)))
         (when (or (null ch)
                   (not (char-whitespace-p ch))) ;;TODO comments
             (return)))
       (setf pieces (with-last pieces (multiple-value-list (read-tokens stream)))))
    (let ((stack (list (list 0 tokens)))) ;;level, expression, multi-expression body?
      (labels ((process-expression (tokens level)
                 (let ((top (car stack)))
                   (if (>= level (car top))
                       (push (list level tokens) stack)
                       (let* ((top (pop stack)) (expr (seq (second top))))
                         (loop
                            :while (and stack (= (car (car stack)) (car top)))
                            :do (setf expr (with-first expr (second (pop stack)))))
                         (setf (second (car stack))
                               (if (seq? (second (car stack)))
                                   (concat (second (car stack)) expr)
                                   (with-first expr (second (car stack)))))
                         (process-expression tokens level))))))
        (do-seq (p pieces)
          (process-expression (car p) (cadr p)))
        (process-expression (seq) 0) ;;Consume remaining tokens
        (pop stack) ;;Remove the extra empty expression introduced above
        (let* ((top (pop stack))
               (level (car top))
               (tokens (seq (second top))))
          ;;Sanity checks
          (assert (not stack))
          (assert (zerop level))
          (assert (= (size tokens) 1))
          (first tokens))))))

(defun consume-whitespace (stream &optional (stop-at-eol? t))
  (let ((count 0))
    (loop
       (let ((ch (read-char stream nil)))
         (when (null ch)
           (return count))
         (if (char-whitespace-p ch) ;;TODO comments
             (incf count)
             (if (and (not stop-at-eol?) (char-line-terminator-p ch))
                 (setf count 0)
                 (progn
                   (unread-char ch stream)
                   (return count))))))))

(defun read-tokens (stream)
  (let ((indent (consume-whitespace stream nil))
        (tokens (seq)))
    ;;If there's nothing to read, return early
    (let ((ch (peek-char nil stream nil)))
      (when (null ch) ;;TODO is nil the right thing to return here?
        (return-from read-tokens)))
    (loop
       (setf tokens (with-last tokens (read-object stream)))
       (consume-whitespace stream)
       (let ((ch (peek-char nil stream nil)))
         (when (or (null ch) (char-line-terminator-p ch)) ;;TODO split over multiple lines with \
           (read-line stream nil) ;;Consume remaining characters
           (return (values
                    (if (= (size tokens) 1)
                        (first tokens)
                        tokens)
                    indent)))))))

